home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-11
/
butt01.zip
/
UTIL.INC
< prev
Wrap
Text File
|
1993-01-04
|
7KB
|
231 lines
<<* Util.Inc *>>
<<#pragma
<<************************************************************>>
procedure SetIndent( IndentTab : integer )
<<* set system indent value based on a tab value *>>
begin
<<* Save old value so it can be restored *>>
<<* Tab Value = indent space(3) at a time *>>
set lmargin to lmargin + (IndentTab * 3)
end SetIndent
<<************************************************************>>
procedure RestoreIndent( IndentTab : integer )
<<* Restore previous indent as saved VIA SetIndent *>>
begin
set lmargin to lmargin - (IndentTab * 3)
end RestoreIndent
<<************************************************************>>
function HowMany(Target,Host : string) : integer
<<* Count the number of occurances of Target in the Host *>>
integer count
begin
count := 0
while (Target $ Host)
Host := stuff(Host,1,at(Target,Host),'')
count := count +1
end
return count
end
<<************************************************************>>
function GetUser(CmdPointer : integer ; CmdLine : string) : string
<<* This is a recursive function used to retrieve the n_th entry
from the user field. Semicolon is the field separator. 16 is the
maximum CmdPointer value allowed. *>>
begin
if CmdPointer <= 1
if at(';',CmdLine) = 1
return '' <<* value is null. ie ;; *>>
else
if at(';',CmdLine) = 0
return CmdLine <<* no more separators on the line *>>
endif
return left(CmdLine,at(';',CmdLine)-1)
endif
endif
<<* the next line causes a recursive call *>>
return GetUser(CmdPointer-1,substr(CmdLine,at(';',CmdLine)+1,len(CmdLine)-(at(';',CmdLine)))
end <<* GetUser *>>
<<************************************************************>>
function Seperate(Pointer : integer ; Line,Seperator : string) : string
<<* This is a recursive function used to retrieve the n_th entry
from the LINE. 'Seperator' is the field separator. 16 is the
maximum Pointer value allowed. *>>
begin
if Pointer <= 1
if at(Seperator,Line) = 1
return '' <<* value is null. ie ;; *>>
else
if at(Seperator,Line) = 0
return Line <<* no more separators on the line *>>
endif
return left(Line,at(Seperator,Line)-1)
endif
endif
<<* the next line causes a recursive call *>>
return GetUser(Pointer-1,substr(Line,at(Seperator,Line)+1,len(Line)-(at(Seperator,Line)))
end <<* Seperate *>>
<<************************************************************>>
function AtrCode( atr : integer ) : string
<<* Returns the color attribute in an xBase string form from the
attribute code received in 'atr' *>>
string hilite,blink,hues,atrstrg
integer hinib,lonib
begin
hues := 'N ,BU,G ,BG,R ,BR,GR,W '
if (atr and 8) = 8
hilite := '+'
endif
if (atr and 128) = 128
blink := '*'
endif
lonib := (atr and 7)
hinib := ((atr shr 4) and 7)
atrstrg := rtrim( substr( hues,(lonib * 3) + 1,2 ) ) + blink + hilite + '/'
atrstrg := atrstrg + rtrim( substr( hues,(hinib * 3) + 1,2 ) )
RETURN atrstrg
end <<*AtrCode*>>
<<************************************************************>>
procedure GenColorAtr
integer lastatr
begin
if fldsay
lastatr := forecolor
else
lastatr := backcolor
endif
if (fldatr <> lastatr)
gen( 'SET COLOR TO ' )
if fldget
gen( ',' )
endif
genln( AtrCode(fldatr) )
if fldsay
forecolor := fldatr
else
backcolor := fldatr
endif
endif
end
<<*GenColorAtr*>>
<<************************************************************>>
procedure GenColorHue
<<* Generate a new color setting if the field label color changed *>>
begin
if (fldhue <> lasthue)
genln( 'SET COLOR TO ',AtrCode( fldhue ) )
lasthue := fldhue
endif
end <<*GenColorHue*>>
<<************************************************************>>
procedure WriteLabels
<<* Generate a group of SAYs for field labels and text objects *>>
string box
begin
forall fldlab
if not fldnap
GenColorHue <<* Test for color change *>>
if fldtyp = 'B' <<*BOX Type*>>
box := fldlab <<*Used to swap chars for Character box*>>
gen( '@ ',fldrow,',',fldcol,',' )
gen( fldrow+flddec,',',fldcol+fldwid,' BOX "' )
genln( substr(box,1,3),box[5],box[8],box[7],box[6],box[4],' "' )
else <<*All Fields and Text Objects*>>
genln( '@ ',fldrow,',',fldcol,' SAY "',fldlab,'"' )
endif
endif not fldnap
endfor
end <<*WriteLabels*>>
<<************************************************************>>
procedure GenPicture
<<* Generates a picture based on the field type and width
or uses the one that the user created *>>
string picstrg
begin
if fldpic <<* Picture was created by the user *>>
gen( ' PICTURE ')
if 'REPL'$UPPER(fldpic) <<* REPLICATE() is used as the picture *>>
gen(fldpic)
else <<* Picture needs quotation marks *>>
picstrg := fldpic
while '"' $ picstrg <<* remove " if found *>>
picstrg := stuff(picstrg,at('"',picstrg),1,'')
endwhile
while "'" $ picstrg <<* remove ' if found *>>
picstrg := stuff(picstrg,at("'",picstrg),1,'')
endwhile
if LEN(picstrg) < fldwid <<* Correct field width *>>
if '@'$picstrg <<* no action when it is a function *>>
else
picstrg := replicate( LEFT(picstrg,1),fldwid )
endif
endif
gen( '"',picstrg,'"' )
endif
else <<* No picture by user **>>
if fldtyp = 'N' <<* No picture so Force numeric picture *>>
picstrg := replicate( '9',fldwid )
if flddec
picstrg[ fldwid-flddec ] := '.'
endif
gen( ' PICTURE "',picstrg,'"' )
elsif fldtyp = 'C' <<* No picture so Force character picture *>>
if fldwid > 29
picstrg := replicate( 'X',fldwid )
gen( ' PICTURE REPLICATE("X",',STR(fldwid),')' )
else
picstrg := replicate( 'X',fldwid )
gen( ' PICTURE "',picstrg,'"' )
endif
endif
endif
end <<*GenPicture*>>
<<************************************************************>>
procedure GenFldList( cmdword : string )
<<* Generate a list of variables in groups of 3 lines, 7 per line *>>
integer linecount,linemax,fldtally,memtotal
logical isnewln
begin
linemax := 2 <<* Max Lines -1 *>>
fldtally := 0
linecount := 9
isnewln := true
forall fldtyp $ 'CDLN'
if (UPPER(LEFT(GetUser(1,fldusr),4)) <>'MULT') and not fldnap
if isnewln
linecount := linecount + 1
if linecount > linemax
if linecount < 10
genln <<* not on first pass *>>
endif
genln( cmdword )
linecount := 0
else
genln( ',;' )
endif
gen( space(3) ) <<*indent=3*>>
else
gen( ',' )
endif
fldtally := fldtally + 1
isnewln := (fldtally mod 7 = 0) <<* 7 vars per line *>>
gen( 'm',fldnam )
endif not fldnap
endfor
genln <<*CR/LF*>>
end <<*GenFldList*>>
#>>
<<* EOF: Util.Inc *>>